home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / read-image.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  224 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ;(define-syntax assert
  6. ;  (lambda ignore
  7. ;    ''assert))
  8.  
  9. (define debugging? #t)
  10.  
  11. ; ,bench
  12. ; ,load rts/defenum.scm
  13. ; ,for-syntax ,load my-vm/for-syntax.scm
  14. ; ,load my-vm/s48-prescheme.scm my-vm/util.scm my-vm/memory.scm
  15. ; ,load my-vm/arch.scm my-vm/data.scm my-vm/struct.scm
  16. ; ,load link/s48-features.scm link/read-image.scm
  17. ; ,load-into extended-numbers misc/bigbit.scm
  18.  
  19. (define (resume filename arg)
  20.   (call-startup-procedure (extract (read-image filename)) arg))
  21.  
  22. (define (call-startup-procedure proc arg)
  23.   (proc arg (current-input-port) (current-output-port)))
  24.  
  25. (define level 14)
  26.  
  27. (define (read-image filename)
  28.   (call-with-input-file filename
  29.     (lambda (port)
  30.       (read-page port) ; read past any user cruft at the beginning of the file
  31.       (let* ((old-level          (read-number port))
  32.              (old-bytes-per-cell (read-number port))
  33.              (old-begin (cells->a-units (read-number port)))
  34.              (old-hp    (cells->a-units (read-number port)))
  35.              (startup-proc       (read-number port)))
  36.         (read-page port)
  37.         (if (not (= old-level level))
  38.             (error "format of image is incompatible with this version of system"
  39.                    old-level level))
  40.         (if (not (= old-bytes-per-cell bytes-per-cell))
  41.             (error "incompatible bytes-per-cell"
  42.                    old-bytes-per-cell bytes-per-cell))
  43.  
  44.     ;; ***CHANGED***
  45.     (create-memory (a-units->cells (- (addr1+ old-hp) old-begin))
  46.                quiescent)
  47.     (set! *hp* 0)
  48.  
  49.         (let* ((delta (- *hp* old-begin))
  50.                (new-hp (+ old-hp delta)))
  51.       (let ((reverse? (check-image-byte-order port)))
  52.         (read-block port *memory* *hp* (- old-hp old-begin))
  53.         (if reverse?
  54.         (reverse-byte-order new-hp))
  55.         (if (= delta 0)
  56.         (set! *hp* new-hp)
  57.         (relocate-image delta new-hp))
  58.         (set! *extracted* (make-vector (a-units->cells *memory-end*) #f))
  59.         (adjust startup-proc delta)))))))
  60.  
  61. (define (check-image-byte-order port)
  62.   (read-block port *memory* *hp* (cells->a-units 1))
  63.   (cond ((= (fetch *hp*) 1)
  64.      #f)
  65.     (else
  66.      (reverse-descriptor-byte-order! *hp*)
  67.      (if (= (fetch *hp*) 1)
  68.          #t
  69.          (begin (error "unable to correct byte order" (fetch *hp*))
  70.             #f)))))
  71.  
  72. (define *hp* 0)
  73.  
  74. (define *extracted* #f)
  75.  
  76. (define (extract obj)
  77.   (cond ((vm-fixnum? obj) (extract-vm-fixnum obj))
  78.     ((stob? obj)
  79.      (let ((index (a-units->cells (address-after-header obj))))
  80.        (or (vector-ref *extracted* index)
  81.            (extract-stored-object obj
  82.                       (lambda (new)
  83.                     (vector-set! *extracted* index new)
  84.                     new)))))
  85.     ((vm-char? obj) (extract-char obj))
  86.     ((vm-eq? obj null) '())
  87.     ((vm-eq? obj false) #f)
  88.     ((vm-eq? obj true) #t)
  89.     ((vm-eq? obj vm-unspecific) (if #f 0))
  90.     ((vm-eq? obj unbound-marker) '<unbound>)
  91.     ((vm-eq? obj unassigned-marker) '<unassigned>)
  92.     (else (error "random descriptor" obj))))
  93.  
  94. (define (extract-stored-object old store-new!)
  95.   ((vector-ref stored-object-extractors (header-type (stob-header old)))
  96.    old store-new!))
  97.  
  98. (define stored-object-extractors
  99.   (make-vector stob-count (lambda rest (apply error "no extractor" rest))))
  100.  
  101. (define (define-extractor which proc)
  102.   (vector-set! stored-object-extractors which proc))
  103.  
  104. (define-extractor stob/pair
  105.   (lambda (old store-new!)
  106.     (let ((new (cons #f #f)))
  107.       (store-new! new)
  108.       (set-car! new (extract (vm-car old)))
  109.       (set-cdr! new (extract (vm-cdr old)))
  110.       new)))
  111.  
  112. (define-extractor stob/vm-closure
  113.   (lambda (old store-new!)
  114.     (store-new! (make-closure (extract (vm-closure-template old))
  115.                   (extract (vm-closure-env old))))))
  116.  
  117. (define-extractor stob/symbol
  118.   (lambda (obj store-new!)
  119.     (store-new! (string->symbol (extract (vm-symbol->string obj))))))
  120.  
  121. (define-extractor stob/vm-location
  122.   (lambda (obj store-new!)
  123.     (let ((new (store-new! (make-undefined-location
  124.                     (+ 10000
  125.                    (extract (vm-location-id obj))))))
  126.       (val (vm-contents obj)))
  127.       (if (not (vm-eq? val unbound-marker))
  128.       (begin (set-location-defined?! new #t)
  129.          (if (not (vm-eq? val unassigned-marker))
  130.              (set-contents! new (extract val)))))
  131.       new)))
  132.  
  133. (define-extractor stob/string
  134.   (lambda (obj store-new!)
  135.     (store-new! (extract-string obj))))
  136.  
  137. (define-extractor stob/vm-code-vector
  138.   (lambda (obj store-new!)
  139.     (store-new! (extract-code-vector obj))))
  140.  
  141. (define-extractor stob/vector
  142.   (lambda (obj store-new!)
  143.     (let* ((z (vm-vector-length obj))
  144.        (v (make-vector z)))
  145.       (store-new! v)
  146.       (do ((i 0 (+ i 1)))
  147.       ((= i z) v)
  148.     (vector-set! v i (extract (vm-vector-ref obj i)))))))
  149.  
  150. ;(define-extractor stob/record
  151. ;  (lambda (obj store-new!)
  152. ;    (let* ((z (vm-record-length obj))
  153. ;           (v (make-record z)))
  154. ;      (store-new! v)
  155. ;      (do ((i 0 (+ i 1)))
  156. ;          ((= i z) v)
  157. ;        (record-set! v i (extract (vm-record-ref obj i)))))))
  158.  
  159. (define-extractor stob/port
  160.   (lambda (obj store-new!)
  161.     (store-new!
  162.      (case (extract-vm-fixnum (port-index obj))
  163.        ((0) (current-input-port))
  164.        ((1) (current-output-port))
  165.        (else (error "unextractable port" obj))))))
  166.  
  167.  
  168.  
  169. (define (extract-code-vector x)
  170.   (let ((z (vm-code-vector-length x)))
  171.     (let ((v (make-code-vector z 0)))
  172.       (do ((i 0 (+ i 1)))
  173.           ((>= i z) v)
  174.         (code-vector-set! v i (vm-code-vector-ref x i))))))
  175.  
  176.  
  177.  
  178. ; Various things copied from vm/gc.scm
  179.  
  180. (define (store-next! descriptor)
  181.   (store! *hp* descriptor)
  182.   (set! *hp* (addr1+ *hp*)))
  183.  
  184. (define (reverse-descriptor-byte-order! addr)
  185.   (let ((x (fetch-byte addr)))
  186.     (store-byte! addr (fetch-byte (addr+ addr 3)))
  187.     (store-byte! (addr+ addr 3) x))
  188.   (let ((x (fetch-byte (addr+ addr 1))))
  189.     (store-byte! (addr+ addr 1) (fetch-byte (addr+ addr 2)))
  190.     (store-byte! (addr+ addr 2) x)))
  191.  
  192. (define (reverse-byte-order end)
  193.   (write-string "Correcting byte order of resumed image."
  194.          (current-output-port))
  195.   (newline (current-output-port))
  196.   (let loop ((ptr *hp*))
  197.     (reverse-descriptor-byte-order! ptr)
  198.     (let ((value (fetch ptr)))
  199.       (if (addr< ptr end)
  200.       (loop (if (b-vector-header? value)
  201.             (addr+ (addr1+ ptr) (header-a-units value))
  202.             (addr1+ ptr)))))))
  203.  
  204. (define (adjust descriptor delta)
  205.   (if (stob? descriptor)
  206.       (make-stob-descriptor (addr+ (address-after-header descriptor) delta))
  207.       descriptor))
  208.  
  209. (define (relocate-image delta new-hp)
  210.   (let loop ()
  211.     (cond ((addr< *hp* new-hp)
  212.        (let ((d (adjust (fetch *hp*) delta)))
  213.          (store-next! d)
  214.          (cond ;;((eq? d the-primitive-header)
  215.            ;; Read symbolic label name.
  216.            ;;(store-next!
  217.            ;;  (label->fixnum (name->label (read port)))))
  218.            ((b-vector-header? d)
  219.         (set! *hp* (addr+ *hp*
  220.                   (cells->bytes
  221.                    (bytes->cells
  222.                     (header-length-in-bytes d)))))))
  223.          (loop))))))
  224.